home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / examples / old / demo / mouse-doc.l < prev    next >
Encoding:
Text File  |  1989-07-12  |  13.2 KB  |  339 lines
  1. ;;; -*- Mode:Lisp; Package:XLIB; Base:10; Syntax:Common-Lisp; Lowercase:T -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1988 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. ;;; Created 2/29/88 by LaMott G. Oren
  20.  
  21. ;;; Change history:
  22. ;;;
  23. ;;;  Date    Author    Description
  24. ;;; -------------------------------------------------------------------------------------
  25. ;;;  02/29/88   LGO     Created
  26. ;;;  07/14/88   SLM     Macro-expand inline definitions for function TICL:PV, which is defined
  27. ;;;                     in the PUBLIC directory.  Don't want dependencies on non-standard software.
  28. ;;;  07/15/88   SLM     Round width and height to whole numbers to prevent text display errors
  29.  
  30. (in-package 'xlib :use '(lisp))
  31.  
  32. (export 'mouse-doc)
  33.  
  34. (defun mouse-doc (host &rest args &key (font "fg-16") (width 80) (height 1) (border-width 1) debug)
  35.   ;; X11 client for printing mouse documentation strings using FONT
  36.   ;; IN ITS OWN WINDOW on HOST.  Width and height are in characters.
  37.   ;;
  38.   ;; This program looks for and displays the WM_DOCUMENTATION property
  39.   ;; on the window the mouse is in.
  40.   (let* ((xlib::*recursive-event-queue* nil)
  41.      (display (open-display host))
  42.      (screen (display-default-screen display))
  43.      (root (screen-root screen))
  44.      (black (screen-black-pixel screen))
  45.      (white (screen-white-pixel screen))
  46.      (font (open-font display font))
  47.      (border 1)                ; Minimum margin around the text
  48.      ;; Convert width and height from characters to pixels
  49.      (width (round (* width (max-char-width font))))
  50.      (height (round (+ (* height (+ (max-char-ascent font) (max-char-descent font))) (* 2 border))))
  51.      (bw2 (+ border-width border-width))
  52.      ;; Initial placement is in lower-left hand corner
  53.      (x (- (screen-width screen) width bw2))
  54.      (y (- (screen-height screen) height bw2))
  55.      
  56.      (doc-window (create-window
  57.                :parent root
  58.                :x x :y y :width width :height height
  59.                :background black
  60.                :border white
  61.                :border-width border-width
  62.                :colormap (screen-default-colormap screen)
  63.                :bit-gravity :center))
  64.  
  65.      (gcontext (create-gcontext
  66.              :drawable doc-window
  67.              :background black
  68.              :foreground white
  69.              :font font))
  70.      (event-state 0)
  71.      (string "")
  72.      (pointer-window nil))  ;The window we think the mouse is in.
  73.     ;; Set window manager hints
  74.     (set-standard-properties doc-window
  75.                  :name 'mouse-documentation
  76.                  :icon-name "Mouse Doc"
  77.                  :resource-name 'mouse-doc
  78.                  :resource-class 'mouse-doc
  79.                  :command (list* 'mouse-doc host args)
  80.                  :x x :y y :width width :height height
  81.                  :min-width width :min-height height
  82.                  :input :off :initial-state :normal)
  83.     
  84.     (unwind-protect
  85.     (macrolet
  86.       ((window-doc (window) `(getf (window-plist ,window) :documentation))
  87.        (window-children (window) `(getf (window-plist ,window) :children)))
  88.       (labels
  89.  
  90.         ((get-documentation (window &optional parent-doc)
  91.            ;; Get the documentation properties for WINDOW and all its descendants.
  92.            (declare (type window window))
  93.            (when debug 
  94.          (format *debug-io* "~%;;~@{~<~%;;~1:; ~@[~a~] ~s~>~^,~2,10t~}." (quote nil) 'get-documentation
  95.              'window window) )  ;;this format statement used to be a call to TICL:PV
  96.            ;; Find and save WM documentation if the window doesn't already have its own.
  97.            (unless (window-doc window)
  98.          (multiple-value-bind (doc type format)
  99.              (get-property window :wm_documentation :type :string
  100.                    :result-type 'string :transform #'card8->char)
  101.            (unless (eq type :string)
  102.              (setq doc (get-property
  103.                  window :wm_documentation :type type
  104.                  :result-type (if (= format 8) '(array card8) '(array card16)))))
  105.            (when (and debug doc) (format t "~%~s ~d  ~a" window (window-id window) doc))
  106.            (setq parent-doc (or doc parent-doc :unknown))
  107.            (setf (window-doc window) parent-doc)
  108.            (setf (window-event-mask window)
  109.              (if (not (eq parent-doc :unknown))
  110.                  '(:enter-window :leave-window)
  111.                '(:enter-window :leave-window)))))
  112.            (let ((tree (query-tree window)))
  113.          (setf (window-children window) tree)
  114.          (dolist (w tree)
  115.            (get-documentation w parent-doc))))
  116.  
  117.          (pointer-window (pointer-window)
  118.         ;; Find the leaf window under the pointer, starting from pointer-window
  119.         (loop
  120.           (multiple-value-bind (x y same-screen-p child)
  121.               (query-pointer pointer-window)
  122.             (declare (ignore x y same-screen-p))
  123.             (setq pointer-window child))
  124.           (when debug 
  125.             (format *debug-io* "~%;;~@{~<~%;;~1:; ~@[~a~] ~s~>~^,~2,10t~}." (quote nil)
  126.                 '**********-query-pointer 'pointer-window pointer-window))  ;;another expansion of TICL:PV
  127.           (unless pointer-window (return nil))
  128.           (unless (window-children pointer-window)
  129.             (return pointer-window))))
  130.  
  131.          (remove-window (window)
  132.         ;; Remove WINDOW and all its descendants from the window cache
  133.         (deallocate-resource-id display (window-id window) 'window)
  134.         (dolist (w (window-children window))
  135.           (remove-window w)))
  136.  
  137.          (display ()
  138.            ;; Display the current documentation string (if any)
  139.            (typecase string
  140.          (string
  141.           (let ((x 0)
  142.             (y (max-char-ascent font)))
  143.             ;; Draw text centered in window in Y direction
  144.             (draw-glyphs doc-window gcontext x y string)))
  145.          ((array card8)
  146.           (display-window-doc doc-window gcontext string *x-polytext8* event-state height))
  147.          ((array card16)
  148.           (display-window-doc doc-window gcontext string *x-polytext16* event-state height))
  149.          ))
  150.  
  151.          (look-ahead (display timeout)
  152.         ;; Returns T when enter-notify events are in the event queue
  153.         (event-case (display :peek-p t :timeout timeout)
  154.           ((enter-notify leave-notify) () t))))
  155.         
  156.         ;; Initialize
  157.         (dolist (screen (display-roots display))
  158.           (get-documentation (screen-root screen))
  159.           (setf (window-event-mask (screen-root screen))
  160.             '( :enter-window :leave-window    ;; Watch the mouse
  161.               :key-press :key-release        ;; Watch the modifier keys
  162.               :substructure-notify)))        ;; Watch for destroy-notify
  163.         (setf (window-event-mask doc-window) '(:exposure :button-press :structure-notify))
  164.         (map-window doc-window)
  165.         
  166.         (setq pointer-window (pointer-window (screen-root screen)))
  167.         (setq string (and pointer-window (window-doc pointer-window)))
  168.  
  169.         ;; Handle events
  170.         (event-case (display :discard-p t :force-output-p t)
  171.           (configure-notify ;; Keep width and height current
  172.         ((window event-window) (width new-width) (height new-height) (border-width new-border-width))
  173.         (when debug 
  174.           (format *debug-io* "~%;;~@{~<~%;;~1:; ~@[~a~] ~s~>~^,~2,10t~}." (quote nil) 'configure-notify
  175.               'event-window event-window 'doc-window doc-window 'new-width new-width 'new-height
  176.               new-height 'new-border-width new-border-width) )
  177.         (when debug (print (make-event-keys (window-event-mask doc-window))))
  178.         (when (window-equal event-window doc-window)
  179.           (setq width new-width
  180.             height new-height
  181.             border-width new-border-width)
  182.           (display))
  183.         nil)
  184.  
  185.           (exposure  ;; Refresh on demand
  186.         ((window event-window) count)
  187.         (when debug 
  188.           (format *debug-io* "~%;;~@{~<~%;;~1:; ~@[~a~] ~s~>~^,~2,10t~}." (quote nil) 'exposure
  189.               'event-window event-window 'count count) )
  190.         (when (and (zerop count) ;; Ignore all but the last exposure event
  191.                (window-equal event-window doc-window))
  192.           (display)
  193.           ;; Returning non-nil causes event-case to exit
  194.           nil))
  195.  
  196.           (key-press ;; If a modifier key is pressed, update the event-state
  197.         ((window event-window) code state)
  198.         (let* ((keysym (keycode->keysym display code 0))
  199.                (mapping (get-display-modifier-mapping display))
  200.                (mask (assoc keysym mapping)))
  201.           (when mask
  202.             (setq event-state (logior state (cdr mask)))
  203.             (when string (clear-area doc-window))
  204.             (display)))
  205.         (when debug 
  206.           (format *debug-io* "~%;;~@{~<~%;;~1:; ~@[~a~] ~s~>~^,~2,10t~}." (quote nil) 'key-press
  207.               'event-window event-window 'code code 'state state '(make-state-keys event-state)
  208.               (make-state-keys event-state)) )
  209.         nil)
  210.  
  211.           (key-release  ;; If a modifier key is released, update the event-state
  212.         ((window event-window) code state)
  213.         (let* ((keysym (keycode->keysym display code 0))
  214.                (mapping (get-display-modifier-mapping display))
  215.                (mask (assoc keysym mapping)))
  216.           (when mask
  217.             (setq event-state (logandc2 state (cdr mask)))
  218.             (when string (clear-area doc-window))
  219.             (display)))
  220.         (when debug 
  221.           (format *debug-io* "~%;;~@{~<~%;;~1:; ~@[~a~] ~s~>~^,~2,10t~}." (quote nil) 'key-release
  222.               'event-window event-window 'code code 'state state '(make-state-keys event-state)
  223.               (make-state-keys event-state)) )
  224.         nil)
  225.  
  226.           ;; Enter-notify is selected only on those windows known to have documentation
  227.           (enter-notify
  228.         ((window event-window) state kind mode)
  229.         (when debug 
  230.           (format *debug-io* "~%;;~@{~<~%;;~1:; ~@[~a~] ~s~>~^,~2,10t~}." (quote nil) 'enter-notify
  231.               'event-window event-window 'kind kind 'mode mode) )
  232.         (setq pointer-window event-window)
  233.         (setq event-state state)
  234.         (unless (look-ahead display 0)
  235.           (let ((doc (or (window-doc event-window)
  236.                  (get-documentation event-window))))
  237.             (when (setq string (if (eq doc :unknown) nil doc))
  238.               (display)))
  239.           nil))
  240.  
  241.           ;; Rather than select substructure-notify on the world, we select
  242.           ;; leave-notify, and make sure we know about all the windows the
  243.           ;; mouse will be in.
  244.           (leave-notify
  245.         (child kind mode window)
  246.         (when debug 
  247.           (format *debug-io* "~%;;~@{~<~%;;~1:; ~@[~a~] ~s~>~^,~2,10t~}." (quote nil) 'leave-notify 'child
  248.               child 'kind kind 'mode mode 'window window) )
  249.         (when string
  250.           (clear-area doc-window)
  251.           (setq string nil))
  252.         (unless (look-ahead display 0.3) ;; when no enter-notify follows
  253.           ;; Must have moved to a window we don't know about... Find it!
  254.           (setq pointer-window (pointer-window (screen-root screen)))
  255.           (when debug 
  256.             (format *debug-io* "~%;;~@{~<~%;;~1:; ~@[~a~] ~s~>~^,~2,10t~}." (quote nil)
  257.                 '****-finding-pointer-window*** 'pointer-window pointer-window) )
  258.           (when (and pointer-window (not (window-doc pointer-window)))
  259.             (get-documentation pointer-window)
  260.             (setq pointer-window (pointer-window pointer-window))
  261.             (when (setq string (and pointer-window (window-doc pointer-window)))
  262.               (display))))
  263.         nil)
  264.  
  265.           (map-notify
  266.         ((window event-window)) (when debug 
  267.                       (format *debug-io* "~%;;~@{~<~%;;~1:; ~@[~a~] ~s~>~^,~2,10t~}." (quote nil) 'map-notify
  268.                           'event-window event-window) )
  269.         (when (not (window-doc event-window))
  270.           (get-documentation event-window))
  271.         nil)
  272.  
  273.           ;; When window is destroyed, Remove window-id's from cache
  274.           (destroy-notify
  275.         ((window event-window)) (when debug 
  276.                       (format *debug-io* "~%;;~@{~<~%;;~1:; ~@[~a~] ~s~>~^,~2,10t~}." (quote nil) 'destroy-notify
  277.                           'event-window event-window) )
  278.         (remove-window event-window)
  279.         nil)
  280.  
  281.           (button-press () t)))) ;; Pressing any mouse-button exits
  282.  
  283.       ;; Ensure display is closed when done
  284.       (close-display display))))
  285.  
  286. (defun display-window-doc (window gcontext data request event-state height)
  287.   (do* ((i 0 (+ i length))
  288.     (start 0)
  289.     (end (length data))
  290.     (length 0 0)
  291.     (state 0)
  292.     (select 0)
  293.     (display (window-display window))
  294.     ;;(window-height (screen-height (display-default-screen display)))
  295.     (font (gcontext-font gcontext))
  296.     (line-height (+ (max-char-ascent font) (max-char-descent font) 2))
  297.     (x 0)
  298.     (y (max-char-ascent font)))
  299.        ((< height (+ y line-height)))        ;;Remove this condition to make any and all text display 
  300.                         ;;even if there's not enough height for the whole line to show.
  301.                         ;;Otherwise, this is an efficiency hack.
  302.     (when (< i end) (setq length (aref data i)))
  303.     (case length
  304.       (0                    ; New state/select, or end
  305.        ;; Display previously scanned text
  306.        (when (and (zerop (logand select (logxor state event-state)))
  307.           (< start i))
  308.      (setq length (- i start))
  309.      (with-buffer-request (display request :gc-force gcontext :length length)
  310.        (drawable window)
  311.        (gcontext gcontext)
  312.        (int16 x y)
  313.        (progn
  314.          (let ((boffset (index+ buffer-boffset length 16)))
  315.            (buffer-replace buffer-bbuf data
  316.                    (index+ buffer-boffset 16)
  317.                    boffset
  318.                    start)
  319.            ;; Ensure terminated with zero bytes
  320.            (do ((end (the array-index (lround boffset))))
  321.            ((index>= boffset end))
  322.          (setf (aref buffer-bbuf boffset) 0)
  323.          (index-incf boffset))
  324.            (length-put 2 (index-ash (index- (lround boffset) buffer-boffset) -2)) ;; Set request length
  325.            (setf (buffer-boffset display) (lround boffset)))
  326.          (incf y line-height))))
  327.        ;; Check for termination
  328.        (when (>= i (- end 5)) (return nil))
  329.        ;; Get new state/select
  330.        (setq state (dpb (aref data (+ i 1)) (byte 8 8) (aref data (+ i 2)))
  331.          select (dpb (aref data (+ i 3)) (byte 8 8) (aref data (+ i 4)))
  332.          length 5
  333.          start (+ i length)))
  334.       (255                    ; New Font
  335.        (setq length 5))
  336.       (otherwise                ; More text
  337.     (incf length 2)))))
  338.  
  339.